home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 24 / CU Amiga Magazine's Super CD-ROM 24 (1998)(EMAP Images)(GB)(Track 1 of 2)[!][issue 1998-07].iso / CUCD / Programming / SWI / source / src / pl-gc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-11-14  |  48.6 KB  |  1,917 lines
  1. /*  $Id: pl-gc.c,v 1.45 1997/11/14 16:25:27 jan Exp $
  2.  
  3.  
  4.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  5.     See ../LICENCE to find out about your rights.
  6.     jan@swi.psy.uva.nl
  7.  
  8.     Purpose: Garbage Collection
  9. */
  10.  
  11. #ifdef SECURE_GC
  12. #define O_DEBUG 1
  13. #define O_SECURE 1
  14. #endif
  15. #include "pl-incl.h"
  16.  
  17. #ifndef HAVE_MEMMOVE            /* Note order!!!! */
  18. #define memmove(dest, src, n) bcopy(src, dest, n)
  19. #endif
  20. #undef ulong
  21. #define ulong unsigned long
  22.  
  23. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  24. This module is based on
  25.  
  26.     Karen Appleby, Mats Carlsson, Seif Haridi and Dan Sahlin
  27.     ``Garbage Collection for Prolog Based on WAM''
  28.     Communications of the ACM, June 1988, vol. 31, No. 6, pages 719-741.
  29.  
  30. Garbage collection is invoked if the WAM  interpreter  is  at  the  call
  31. port.   This  implies  the current environment has its arguments filled.
  32. For the moment we assume the other  reachable  environments  are  filled
  33. completely.   There  is  room  for some optimisations here.  But we will
  34. exploit these later.
  35.  
  36. The sole fact that the garbage collector can  only  be  invoked  if  the
  37. machinery  is  in a well known phase of the execution is irritating, but
  38. sofar I see no solutions around this, nor have had any indications  from
  39. other  Prolog implementors or the literature that this was feasible.  As
  40. a consequence however, we should start the garbage collector well before
  41. the system runs out of memory.
  42.  
  43. In theory, we could have the compiler calculating the maximum amount  of
  44. global   stack   data  created  before  the  next  `save  point'.   This
  45. unfortunately is not possible for the trail stack, which  also  benifits
  46. from  a  garbage  collection pass.  Furthermore, there is the problem of
  47. foreign code creating global stack data (=../2, name/2, read/1, etc.).
  48.  
  49.  
  50.           CONSEQUENCES FOR THE VIRTUAL MACHINE
  51.  
  52. The virtual machine interpreter now should ensure the stack  frames  are
  53. in  a predicatable state.  For the moment, this implies that all frames,
  54. except for the current one (which only has its arguments filled)  should
  55. be  initialised fully.  I'm not yet sure whether we can't do better, but
  56. this is simple and save and allows us to  debug  the  garbage  collector
  57. first before starting on the optimisations.
  58.  
  59.  
  60.         CONSEQUENCES FOR THE DATA REPRESENTATION
  61.  
  62. The garbage collector needs two bits on each cell of `Prolog  data'.   I
  63. decided  to  use the low order two bits for this.  The advantage of this
  64. that pointers to word aligned data are not affected (at least on 32 bits
  65. machines.  Unfortunately, you will have to use 4 bytes alignment  on  16
  66. bits  machines  now  as  well).   This demand only costs us two bits for
  67. integers, which are now shifted two bits to the left when stored on  the
  68. stack.   The  normal  Prolog machinery expects the lower two bits of any
  69. Prolog data object to be zero.  The  garbage  collection  part  must  be
  70. carefull to strip of these two bits before operating on the data.
  71.  
  72. Finally, for the compacting phase we should be able to scan  the  global
  73. stack  both  upwards  and downwards while identifying the objects in it.
  74. This implies reals are  now  packed  into  two  words  and  strings  are
  75. surrounded by a word at the start and end, indicating their length.
  76.  
  77.                   DEBUGGING
  78.  
  79. Debugging a garbage collector is a difficult job.  Bugs --like  bugs  in
  80. memory  allocation--  usually  cause  crashes  long  after  the  garbage
  81. collection has finished.   To  simplify  debugging  a  large  number  of
  82. actions  are  counted  during garbage collection.  At regular points the
  83. consistency between these counts  is  verified.   This  causes  a  small
  84. performance degradation, but for the moment is worth this I think.
  85.  
  86. If the O_SECURE cpp flag is set  some  additional  expensive  consistency
  87. checks  that need considerable amounts of memory and cpu time are added.
  88. Garbage collection gets about 3-4 times as slow.
  89. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  90.  
  91. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  92. Marking, testing marks and extracting values from GC masked words.
  93. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  94.  
  95. #define GC_MASK        (MARK_MASK|FIRST_MASK)
  96. #define VALUE_MASK    (~GC_MASK)
  97.  
  98. #if O_SECURE
  99. char tmp[256];                /* for calling print_val(), etc. */
  100. #define check_relocation(p) do_check_relocation(p, __FILE__, __LINE__)
  101. #define recordMark(p)   { if ( (p) < gTop ) *mark_top++ = (p); }
  102. #else
  103. #define recordMark(p)
  104. #define needsRelocation(p) { needs_relocation++; }
  105. #define check_relocation(p)
  106. #endif
  107.  
  108. #define ldomark(p)    { *(p) |= MARK_MASK; }
  109. #define domark(p)    { if ( marked(p) ) \
  110.                 sysError("marked twice: 0x%p (*= 0x%lx), gTop = 0x%p", p, *(p), gTop); \
  111.               *(p) |= MARK_MASK; \
  112.               total_marked++; \
  113.               recordMark(p); \
  114.               DEBUG(4, Sdprintf("marked(0x%p)\n", p)); \
  115.             }
  116. #define unmark(p)    (*(p) &= ~MARK_MASK)
  117. #define marked(p)    (*(p) & MARK_MASK)
  118.  
  119. #define mark_first(p)    (*(p) |= FIRST_MASK)
  120. #define unmark_first(p)    (*(p) &= ~FIRST_MASK)
  121. #define is_first(p)    (*(p) & FIRST_MASK)
  122. #define is_ref(w)    isRef(w)
  123.  
  124. #define get_value(p)    (*(p) & VALUE_MASK)
  125. #define set_value(p, w)    { *(p) &= GC_MASK; *(p) |= w; }
  126. #define val_ptr2(w, s)    ((Word)((ulong)valPtr2((w), (s)) & ~0x3L))
  127. #define val_ptr(w)    val_ptr2((w), storage(w))
  128.  
  129. #define inShiftedArea(area, shift, ptr) \
  130.     ((char *)ptr >= (char *)LD->stacks.area.base + shift && \
  131.      (char *)ptr <  (char *)LD->stacks.area.max + shift )
  132. #define topPointerOnStack(name, addr) \
  133.     ((char *)(addr) >= (char *)LD->stacks.name.base && \
  134.      (char *)(addr) <  (char *)LD->stacks.name.max)
  135.  
  136. #define onGlobal(p)    onStackArea(global, p) /* onStack()? */
  137. #define onLocal(p)    onStackArea(local, p)
  138. #define onTrail(p)    topPointerOnStack(trail, p)
  139.  
  140.          /*******************************
  141.          *     FUNCTION PROTOTYPES    *
  142.          *******************************/
  143.  
  144. forwards void        mark_variable(Word);
  145. forwards void        mark_foreign(void);
  146. forwards void        sweep_foreign(void);
  147. forwards QueryFrame    mark_environments(LocalFrame);
  148. forwards TrailEntry    mark_choicepoints(LocalFrame, TrailEntry);
  149. forwards void        mark_stacks(LocalFrame);
  150. forwards void        mark_phase(LocalFrame);
  151. forwards void        update_relocation_chain(Word, Word);
  152. forwards void        into_relocation_chain(Word, int stg);
  153. forwards void        compact_trail(void);
  154. forwards void        sweep_mark(mark *);
  155. forwards void        sweep_trail(void);
  156. forwards LocalFrame    sweep_environments(LocalFrame);
  157. forwards LocalFrame    sweep_choicepoints(LocalFrame);
  158. forwards void        sweep_stacks(LocalFrame);
  159. forwards void        sweep_local(LocalFrame);
  160. forwards bool        is_downward_ref(Word);
  161. forwards bool        is_upward_ref(Word);
  162. forwards void        compact_global(void);
  163. forwards void        collect_phase(LocalFrame);
  164.  
  165. #if O_SECURE
  166. forwards int        cmp_address(const void *, const void *);
  167. forwards void        do_check_relocation(Word, char *file, int line);
  168. forwards void        needsRelocation(Word);
  169. forwards bool        scan_global(int marked);
  170. #endif
  171.  
  172.         /********************************
  173.         *           GLOBALS             *
  174.         *********************************/
  175.  
  176. static long total_marked;    /* # marked global cells */
  177. static long trailcells_deleted;    /* # garbage trailcells */
  178. static long relocation_chains;    /* # relocation chains (debugging) */
  179. static long relocation_cells;    /* # relocation cells */
  180. static long relocated_cells;    /* # relocated cells */
  181. static long needs_relocation;    /* # cells that need relocation */
  182. static long local_marked;    /* # cells marked local -> global ptrs */
  183. #if O_SHIFT_STACKS || O_SECURE || defined(O_MAINTENANCE) || defined(O_DEBUG)
  184. static long local_frames;    /* frame count for debugging */
  185. #endif
  186. #if O_SECURE
  187. static long trailtops_marked;
  188. #endif
  189.  
  190. #if O_SECURE
  191.         /********************************
  192.         *           DEBUGGING           *
  193.         *********************************/
  194.  
  195. static Word *mark_base;            /* Array of marked cells addresses */
  196. static Word *mark_top;            /* Top of this array */
  197. static Table check_table = NULL;    /* relocation address table */
  198.  
  199. static void
  200. needsRelocation(Word addr)
  201. { needs_relocation++;
  202.  
  203.   addHTable(check_table, addr, (Void) TRUE);
  204. }
  205.  
  206.  
  207. static char *
  208. print_adr(Word adr, char *buf)
  209. { char *name;
  210.   Word base;
  211.  
  212.   if ( onGlobal(adr) )
  213.   { name = "global";
  214.     base = gBase;
  215.   } else if ( onLocal(adr) )
  216.   { name = "local";
  217.     base = (Word) lBase;
  218.   } else if ( onTrail(adr) )
  219.   { name = "trail";
  220.     base = (Word) tBase;
  221.   } else
  222.   { Ssprintf(buf, "%p", adr);
  223.     return buf;
  224.   }
  225.  
  226.   Ssprintf(buf, "%p=%s(%d)", adr, name, adr-base);
  227.   return buf;
  228. }
  229.  
  230.  
  231. static char *
  232. print_val(word val, char *buf)
  233. { char *tag_name[] = { "var", "int", "float", "atom",
  234.                "string", "list", "term", "ref" };
  235.   char *stg_name[] = { "static/inline/trail", "global", "local", "reserved" };
  236.  
  237.   Ssprintf(buf, "%s at %s(%ld)",
  238.        tag_name[tag(val)],
  239.        stg_name[storage(val) >> 3],
  240.        val >> LMASK_BITS);
  241.   if ( val & MARK_MASK )
  242.     strcat(buf, "M");
  243.   if ( val & FIRST_MASK )
  244.     strcat(buf, "F");
  245.  
  246.   return buf;
  247. }
  248.  
  249. static void
  250. do_check_relocation(Word addr, char *file, int line)
  251. { Symbol s;
  252.  
  253.   if ( !(s=lookupHTable(check_table, addr)) )
  254.   { char buf1[256];
  255.     char buf2[256];
  256.     sysError("%s:%d: Address %s (%s) was not supposed to be relocated",
  257.          file, line, print_adr(addr, buf1), print_val(*addr, buf2));
  258.     return;
  259.   }
  260.  
  261.   if ( !s->value )
  262.   { sysError("%s:%d: Relocated twice: 0x%lx", file, line, addr);
  263.     return;
  264.   }
  265.  
  266.   s->value = FALSE;
  267. }
  268.  
  269. #endif /* O_SECURE */
  270.  
  271.         /********************************
  272.         *          UTILITIES            *
  273.         *********************************/
  274.  
  275. static inline int
  276. isGlobalRef(word w)
  277. { return storage(w) == STG_GLOBAL;
  278. }
  279.  
  280.  
  281. static inline int
  282. offset_cell(Word p)
  283. { word m = *p;                /* was get_value(p) */
  284.   int offset;
  285.  
  286.   if ( storage(m) == STG_LOCAL )
  287.     offset = wsizeofInd(m) + 1;
  288.   else
  289.     offset = 0;
  290.  
  291.   return offset;
  292. }
  293.  
  294.  
  295. static inline Word
  296. previous_gcell(Word p)
  297. { p--;
  298.   return p - offset_cell(p);
  299. }
  300.  
  301.  
  302. static inline word
  303. makePtr(Word ptr, int tag)
  304. { int stg;
  305.  
  306.   if ( onStackArea(global, ptr) )
  307.     stg = STG_GLOBAL;
  308.   else if ( onStackArea(local, ptr) )
  309.     stg = STG_LOCAL;
  310.   else
  311.   { assert(onStackArea(trail, ptr));
  312.     stg = STG_TRAIL;
  313.   }
  314.  
  315.   return consPtr(ptr, tag|stg);
  316. }
  317.  
  318.  
  319.         /********************************
  320.         *            MARKING            *
  321.         *********************************/
  322.  
  323. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  324. void mark_variable(start)
  325.      Word start;
  326.  
  327. After the marking phase has been completed, the following statements are
  328. supposed to hold:
  329.  
  330.     - All non-garbage cells on the local- and global stack are
  331.       marked.
  332.     - `total_marked' equals the size of the global stack AFTER
  333.       compacting (e.i. the amount of non-garbage) in words.
  334.     - `needs_relocation' holds the total number of references from the
  335.       argument- and local variable fields of the local stack and the
  336.       internal global stack references that need be relocated. This
  337.       number is only used for consistency checking with the relocation
  338.       statistic obtained during the compacting phase.
  339.  
  340. The marking algorithm forms a two-state machine. While going deeper into
  341. the reference tree, the pointers are reversed  and the FIRST_MASK is set
  342. to indicate the choice points created by   complex terms with arity > 1.
  343. Also the actual mark bit is set on the   cells. If a leaf is reached the
  344. process reverses, restoring the  old  pointers.   If  a  `first' mark is
  345. reached we are either finished, or have reached a choice point, in which
  346. case  the  alternative  is  the  cell   above  (structures  are  handled
  347. last-argument-first).
  348. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  349.  
  350. #define FORWARD        goto forward
  351. #define BACKWARD    goto backward
  352.  
  353. static void
  354. mark_variable(Word start)
  355. { register Word current;        /* current cell examined */
  356.   register word val;            /* old value of current cell */
  357.   register Word next;            /* cell to be examined */
  358.  
  359.   DEBUG(3, Sdprintf("marking 0x%p\n", start));
  360.  
  361.   if ( marked(start) )
  362.     sysError("Attempt to mark twice");
  363.  
  364.   local_marked++;
  365.   current = start;
  366.   mark_first(current);
  367.   val = get_value(current);  
  368.   total_marked--;            /* do not count local stack cell */
  369.   FORWARD;
  370.  
  371. forward:                /* Go into the tree */
  372.   if ( marked(current) )        /* have been here */
  373.     BACKWARD;
  374.   domark(current);
  375.  
  376.   switch(tag(val))
  377.   { case TAG_REFERENCE:
  378.     { next = unRef(val);        /* address pointing to */
  379.       if ( next < gBase )
  380.     sysError("REF pointer to 0x%p\n", next);
  381.       needsRelocation(current);
  382.       if ( is_first(next) )        /* ref to choice point. we will */
  383.         BACKWARD;            /* get there some day anyway */
  384.       val  = get_value(next);        /* invariant */
  385.       set_value(next, makeRef(current));/* create backwards pointer */
  386.       DEBUG(5, Sdprintf("Marking REF from 0x%p to 0x%p\n", current, next));
  387.       current = next;            /* invariant */
  388.       FORWARD;
  389.     }
  390.     case TAG_COMPOUND:
  391.     { int args;
  392.  
  393.       SECURE(assert(storage(val) == STG_GLOBAL));
  394.       next = valPtr2(val, STG_GLOBAL);
  395.       needsRelocation(current);
  396.       if ( marked(next) )
  397.     BACKWARD;            /* term has already been marked */
  398.       args = arityFunctor(((Functor)next)->definition) - 1;
  399.       DEBUG(5, Sdprintf("Marking TERM %s/%d at 0x%p\n",
  400.             stringAtom(nameFunctor(((Functor)next)->definition)),
  401.             args+1, next));
  402.       domark(next);
  403.       for( next += 2; args > 0; args--, next++ )
  404.     mark_first(next);
  405.       next--;                /* last cell of term */
  406.       val = get_value(next);        /* invariant */
  407.                     /* backwards pointer (NO ref!) */
  408.       set_value(next, makePtr(current, TAG_COMPOUND));
  409.       current = next;
  410.       FORWARD;
  411.     }
  412.     case TAG_INTEGER:
  413.       if ( storage(val) == STG_INLINE )
  414.     BACKWARD;
  415.     case TAG_STRING:
  416.     case TAG_FLOAT:            /* indirects */
  417.     { next = valPtr2(val, STG_GLOBAL);
  418.  
  419.       SECURE(assert(storage(val) == STG_GLOBAL));
  420.       needsRelocation(current);
  421.       if ( marked(next) )        /* can be referenced from multiple */
  422.         BACKWARD;            /* places */
  423.       domark(next);
  424.       DEBUG(3, Sdprintf("Marked indirect data type, size = %ld\n",
  425.             offset_cell(next) + 1));
  426.       total_marked += offset_cell(next);
  427.     }
  428.   }
  429.   BACKWARD;
  430.  
  431. backward:                  /* reversing backwards */
  432.   while( !is_first(current) )
  433.   { word w = get_value(current);
  434.  
  435.     next = valPtr(w);
  436.     set_value(current, val);
  437.     if ( isRef(w) )
  438.       val = makeRef(current);
  439.     else
  440.       val = makePtr(current-1, TAG_COMPOUND);
  441.     current= next;
  442.   }
  443.  
  444.   unmark_first(current);
  445.   if ( current == start )
  446.     return;
  447.  
  448.   { word tmp;
  449.  
  450.     tmp = get_value(current);
  451.     set_value(current, val);        /* restore old value */
  452.     current--;
  453.     val = get_value(current);        /* invariant */
  454.     set_value(current, tmp);
  455.     FORWARD;
  456.   }
  457. }
  458.  
  459.  
  460. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  461. References from foreign code.
  462. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  463.  
  464. static void
  465. mark_foreign()
  466. { FliFrame fr = fli_context;
  467.  
  468.   for( ; fr; fr = fr->parent )
  469.   { Word sp = refFliP(fr, 0);
  470.     int n = fr->size;
  471.  
  472.     DEBUG(1, Sdprintf("Marking %d PL_term_refs\n", n));
  473.  
  474.     needsRelocation(&fr->mark.trailtop);
  475.     into_relocation_chain(&fr->mark.trailtop, STG_LOCAL);
  476.  
  477.     for( ; n-- > 0; sp++ )
  478.     { if ( !marked(sp) )
  479.       { if ( isGlobalRef(*sp) )
  480.       mark_variable(sp);
  481.     else
  482.       ldomark(sp);      
  483.       }
  484.     }
  485.   }
  486. }
  487.  
  488.  
  489. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  490. clearUninitialisedVarsFrame(LocalFrame fr, Code PC);
  491.  
  492. Assuming the clause associated will resume   execution  at PC, determine
  493. the variables that are not yet initialised and set them to be variables.
  494. This  avoids  the  garbage  collector    considering  the  uninitialised
  495. variables.
  496.  
  497. [Q] wouldn't it be better to track  the variables that *are* initialised
  498. and consider the others to be not?  Might   take more time, but might be
  499. more reliable and simpler.
  500. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  501.  
  502. void
  503. clearUninitialisedVarsFrame(LocalFrame fr, Code PC)
  504. { if ( PC != NULL )
  505.   { Code branch_end = NULL;
  506.     code c;
  507.  
  508.     for( ; ; PC += (codeTable[c].arguments + 1))
  509.     { c = decode(*PC);
  510.  
  511. #if O_DEBUGGER
  512.     again:
  513. #endif
  514.       switch( c )
  515.       {
  516. #if O_DEBUGGER
  517.     case D_BREAK:
  518.       c = decode(replacedBreak(PC));
  519.       goto again;
  520. #endif
  521. #if O_STRING
  522.     case H_INDIRECT:        /* only skip the size of the */
  523.     case B_INDIRECT:        /* string + header */
  524.     { word m = PC[1];
  525.       PC += wsizeofInd(m)+1;
  526.       break;
  527.     }
  528. #endif
  529.     case I_EXIT:
  530.     case I_EXITFACT:
  531.       return;
  532.     case C_JMP:
  533.       if ( PC >= branch_end )
  534.         branch_end = PC + PC[1] + 2;
  535.       break;
  536.     case B_FIRSTVAR:
  537.     case B_ARGFIRSTVAR:
  538.     case C_VAR:
  539. #if O_SECURE      
  540.       if ( varFrameP(fr, PC[1]) <
  541.            argFrameP(fr, fr->predicate->functor->arity) )
  542.         sysError("Reset instruction on argument");
  543. #endif
  544.       if ( PC >= branch_end )
  545.       {
  546. #if O_SECURE
  547.         assert(varFrame(fr, PC[1]) != QID_MAGIC);
  548. #endif
  549.         setVar(varFrame(fr, PC[1]));
  550.       }
  551.       break;
  552.       }
  553.     }
  554.   }
  555. }
  556.  
  557.  
  558. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  559. Marking the environments.
  560. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  561.  
  562. #ifndef offset
  563. #define offset(s, f) ((int)(&((struct s *)NULL)->f))
  564. #endif
  565.  
  566. static QueryFrame
  567. mark_environments(LocalFrame fr)
  568. { Code PC = NULL;
  569.  
  570.   if ( !fr )
  571.     return NULL;
  572.  
  573.   for( ; ; )
  574.   { int slots;
  575.     Word sp;
  576. #if O_SECURE
  577.     int oslots;
  578. #endif
  579.  
  580.     if ( true(fr, FR_MARKED) )
  581.       return NULL;            /* from choicepoints only */
  582.     set(fr, FR_MARKED);
  583.     
  584.     DEBUG(3, Sdprintf("Marking [%ld] %s\n",
  585.               levelFrame(fr), predicateName(fr->predicate)));
  586.  
  587.     clearUninitialisedVarsFrame(fr, PC);
  588.  
  589.     slots   = (PC == NULL ? fr->predicate->functor->arity : slotsFrame(fr));
  590. #if O_SECURE
  591.     oslots = slots;
  592. #endif
  593.     sp = argFrameP(fr, 0);
  594.     for( ; slots-- > 0; sp++ )
  595.     { if ( !marked(sp) )
  596.       { if ( isGlobalRef(*sp) )
  597.       mark_variable(sp);
  598.     else
  599.       ldomark(sp);      
  600.       }
  601.     }
  602.  
  603.     PC = fr->programPointer;
  604.     if ( fr->parent != NULL )
  605.       fr = fr->parent;
  606.     else
  607.       return (QueryFrame)addPointer(fr, -offset(queryFrame, frame));
  608.   }
  609. }
  610.  
  611. #ifndef O_DESTRUCTIVE_ASSIGNMENT
  612. #define isTrailValueP(x) 0
  613. #endif
  614.  
  615. static TrailEntry
  616. mark_choicepoints(LocalFrame bfr, TrailEntry te)
  617. { for( ; bfr; bfr = bfr->backtrackFrame )
  618.   { Word top = argFrameP(bfr, bfr->predicate->functor->arity);
  619.     TrailEntry tm = (TrailEntry) valPtr2(bfr->mark.trailtop, STG_TRAIL);
  620.  
  621.     for( ; te >= tm; te-- )        /* early reset of vars */
  622.     { if ( tag(te->address) == TAG_TRAILADDR )
  623.       { Word tard = val_ptr(te->address);
  624.  
  625.     if ( tard >= top )
  626.     { te->address = 0;
  627.       trailcells_deleted++;
  628.     } else if ( !marked(tard) )
  629.     { setVar(*tard);
  630. #if O_SECURE
  631.       assert(*tard != QID_MAGIC);
  632. #endif
  633.       DEBUG(3, Sdprintf("Early reset of 0x%p\n", te->address));
  634.       te->address = 0;
  635.       trailcells_deleted++;
  636.     }
  637.       }
  638.     }
  639.  
  640.     set(bfr, FR_CHOICEPT);
  641.     assert(bfr->mark.trailtop != INVALID_TRAILTOP);
  642.     needsRelocation(&bfr->mark.trailtop);
  643.     into_relocation_chain(&bfr->mark.trailtop, STG_LOCAL);
  644.     SECURE(trailtops_marked--);
  645.  
  646.     mark_environments(bfr);
  647.   }
  648.  
  649.   return te;
  650. }
  651.  
  652.  
  653. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  654. mark_stacks() will mark all data that  is   reachable  from any frame or
  655. choicepoint. In addition, it  will  do   `early  reset'  on variables of
  656. choicepoints that will be  reset  anyway   if  backtracking  reaches the
  657. choicepoint. Also, it  will  insert  all   trailtops  of  marks  in  the
  658. relocation chains. A small problem is  the   top-goal  of  a query, This
  659. frame may not be a  choicepoint,  but   its  mark  is  needed anyhow for
  660. PL_close_query(), so it has to be relocated.  `te' in the function below
  661. has to be updated as none of these variables should be reset
  662. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  663.  
  664. static void
  665. mark_stacks(LocalFrame fr)
  666. { QueryFrame query;
  667.   TrailEntry te = tTop - 1;
  668.  
  669.   trailcells_deleted = 0;
  670.  
  671.   for( ; fr; fr = query->saved_environment )
  672.   { query = mark_environments(fr);
  673.     assert(query->magic == QID_MAGIC);
  674.     te    = mark_choicepoints(fr, te);
  675.  
  676.     if ( false(&query->frame, FR_CHOICEPT) ) /* top one is always choicept */
  677.     { LocalFrame bfr = &query->frame;
  678.  
  679.       set(bfr, FR_CHOICEPT);
  680.       assert(te >= (TrailEntry)val_ptr2(bfr->mark.trailtop, STG_TRAIL) - 1);
  681.       te = (TrailEntry)val_ptr2(bfr->mark.trailtop, STG_TRAIL) - 1;
  682.       needsRelocation(&bfr->mark.trailtop);
  683.       into_relocation_chain(&bfr->mark.trailtop, STG_LOCAL);
  684.       SECURE(trailtops_marked--);
  685.     }
  686.   }
  687.   
  688.   DEBUG(2, Sdprintf("Trail stack garbage: %ld cells\n", trailcells_deleted));
  689. }
  690.  
  691.  
  692. #ifdef O_DESTRUCTIVE_ASSIGNMENT
  693. static void
  694. mark_trail()
  695. { TrailEntry te = tTop - 1;
  696.  
  697.   for( ; te >= tBase; te-- )
  698.   { Word gp;
  699.  
  700.     if ( tag(te->address) == TAG_TRAILVAL )
  701.     { gp = val_ptr(te->address);
  702.  
  703.       assert(onGlobal(gp));
  704.       if ( !marked(gp) )
  705.       { local_marked--;            /* fix counters */
  706.     total_marked++;
  707.     mark_variable(gp);
  708.       }
  709.     }
  710.   }
  711. }
  712. #endif /*O_DESTRUCTIVE_ASSIGNMENT*/
  713.  
  714.  
  715. #if O_SECURE
  716. static int
  717. cmp_address(const void *vp1, const void *vp2)
  718. { Word p1 = *((Word *)vp1);
  719.   Word p2 = *((Word *)vp2);
  720.  
  721.   return p1 > p2 ? 1 : p1 == p2 ? 0 : -1;
  722. }
  723. #endif
  724.  
  725.  
  726. static void
  727. mark_phase(LocalFrame fr)
  728. { total_marked = 0;
  729.  
  730.   mark_stacks(fr);
  731.   mark_foreign();
  732. #if O_SECURE
  733.   if ( !scan_global(TRUE) )
  734.     sysError("Global stack currupted after GC mark-phase");
  735.   qsort(mark_base, mark_top - mark_base, sizeof(Word), cmp_address);
  736. #endif
  737.  
  738.   DEBUG(2, { long size = gTop - gBase;
  739.          Sdprintf("%ld referenced cell; %ld garbage (gTop = 0x%p)\n",
  740.               total_marked, size - total_marked, gTop);
  741.        });
  742. }
  743.  
  744.  
  745.         /********************************
  746.         *          COMPACTING           *
  747.         *********************************/
  748.  
  749.  
  750. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  751. Relocation chain management
  752.  
  753. A relocation chain is a linked chain of cells, whose elements all should
  754. point to `dest' after it is unwound.  SWI-Prolog knows about a number of
  755. different pointers.  This routine is supposed  to  restore  the  correct
  756. pointer.  The following types are identified:
  757.  
  758.     source    types
  759.     local    address values (gTop references)
  760.             term, reference and indirect pointers
  761.     trail    address values (reset addresses)
  762.     global    term, reference and indirect pointers
  763.  
  764. To do this, a pointer of the same  type  is  stored  in  the  relocation
  765. chain.
  766.  
  767.     update_relocation_chain(current, dest)
  768.     This function checks whether current is the head of a relocation
  769.     chain.  As we know `dest' is the place  `current'  is  going  to
  770.     move  to,  we  can reverse the chain and have all pointers in it
  771.     pointing to `dest'.
  772.  
  773.     We must clear the `first' bit on the field.
  774. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  775.  
  776. static void
  777. update_relocation_chain(Word current, Word dest)
  778. { Word head = current;
  779.   word val = get_value(current);
  780.  
  781.   DEBUG(3, Sdprintf("unwinding relocation chain at 0x%p to 0x%p\n",
  782.             current, dest));
  783.  
  784.   do
  785.   { int tag;
  786.  
  787.     unmark_first(current);
  788.     current = valPtr(val);
  789.     tag = tag(val);
  790.     val = get_value(current);
  791.     set_value(current, makePtr(dest, tag));
  792.     relocated_cells++;
  793.   } while( is_first(current) );
  794.  
  795.   set_value(head, val);
  796.   relocation_chains--;
  797. }
  798.  
  799.  
  800. static void
  801. into_relocation_chain(Word current, int stg)
  802. { Word head;
  803.   word val = get_value(current);
  804.   
  805.   head = valPtr(val);            /* FIRST/MASK already gone */
  806.   set_value(current, get_value(head));
  807.   set_value(head, consPtr(current, stg|tag(val)));
  808.  
  809.   DEBUG(2, Sdprintf("Into relocation chain: 0x%p (head = 0x%p)\n",
  810.             current, head));
  811.  
  812.   if ( is_first(head) )
  813.     mark_first(current);
  814.   else
  815.   { mark_first(head);
  816.     relocation_chains++;
  817.   }
  818.  
  819.   relocation_cells++;
  820. }
  821.  
  822. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  823. Trail stack compacting.
  824. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  825.  
  826. static void
  827. compact_trail(void)
  828. { TrailEntry dest, current;
  829.   
  830.     /* compact the trail stack */
  831.   for( dest = current = tBase; current < tTop; )
  832.   { if ( is_first(¤t->address) )
  833.       update_relocation_chain(¤t->address, &dest->address);
  834. #if O_SECURE
  835.     else
  836.     { Symbol s;
  837.       if ( (s=lookupHTable(check_table, current)) != NULL && s->value == TRUE )
  838.         sysError("0x%p was supposed to be relocated (*= 0x%p)",
  839.          current, current->address);
  840.     }
  841. #endif
  842.  
  843.     if ( current->address )
  844.       *dest++ = *current++;
  845.     else
  846.       current++;
  847.   }
  848.   if ( is_first(¤t->address) )
  849.     update_relocation_chain(¤t->address, &dest->address);
  850.  
  851.   tTop = dest;
  852.  
  853.   if ( relocated_cells != relocation_cells )
  854.     sysError("After trail: relocation cells = %ld; relocated_cells = %ld\n",
  855.          relocation_cells, relocated_cells);
  856. } 
  857.  
  858.  
  859. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  860. Sweep a mark. This is a bit tricky as the global-stack pointer may point
  861. to  a  garbage  global  cell.  Therefore  we  have  to  find  the  first
  862. non-garbage one. Unfortunately, the cell may  already be in a relocation
  863. chain (in which case `first' is true). In  this case it is not a garbage
  864. cell. Hence the `goto found'.
  865. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  866.  
  867. static void
  868. sweep_mark(mark *m)
  869. { Word gm, prev;
  870.  
  871.   gm = val_ptr2(m->globaltop, STG_GLOBAL);
  872.  
  873.   for(;;)
  874.   { if ( gm == gBase )
  875.     { m->globaltop = consPtr(gm, STG_GLOBAL);
  876.       break;
  877.     }
  878.     if ( is_first(gm-1) )
  879.       goto found;
  880.     prev = previous_gcell(gm);
  881.     if ( marked(prev) )
  882.     {
  883.     found:
  884.       m->globaltop = consPtr(gm, STG_GLOBAL);
  885.       DEBUG(3, Sdprintf("gTop mark from choice point: "));
  886.       needsRelocation(&m->globaltop);
  887.       into_relocation_chain(&m->globaltop, STG_LOCAL);
  888.       break;
  889.     }
  890.     gm = prev;
  891.   }
  892. }
  893.  
  894.  
  895. static void
  896. sweep_foreign()
  897. { FliFrame fr = fli_context;
  898.  
  899.   for( ; fr; fr = fr->parent )
  900.   { Word sp = refFliP(fr, 0);
  901.     int n = fr->size;
  902.  
  903.     sweep_mark(&fr->mark);
  904.     for( ; n-- > 0; sp++ )
  905.     { if ( marked(sp) )
  906.       {    unmark(sp);
  907.     if ( isGlobalRef(get_value(sp)) )
  908.     { local_marked--;
  909.       check_relocation(sp);
  910.       into_relocation_chain(sp, STG_LOCAL);
  911.     }
  912.       }
  913.     }
  914.   }
  915. }
  916.  
  917.  
  918. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  919. Sweeping the local and trail stack to insert necessary pointers  in  the
  920. relocation chains.
  921. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  922.  
  923. static void
  924. sweep_trail(void)
  925. { TrailEntry te = tTop - 1;
  926.  
  927.   for( ; te >= tBase; te-- )
  928.   { if ( te->address )
  929.     {
  930. #ifdef O_DESTRUCTIVE_ASSIGNMENT
  931.       if ( tag(te->address) == TAG_TRAILVAL )
  932.       { needsRelocation(&te->address);
  933.     into_relocation_chain(&te->address, STG_TRAIL);
  934.       } else
  935. #endif
  936.       if ( storage(te->address) == STG_GLOBAL )
  937.       { needsRelocation(&te->address);
  938.     into_relocation_chain(&te->address, STG_TRAIL);
  939.       }
  940.     }
  941.   }
  942. }
  943.  
  944.  
  945. static LocalFrame
  946. sweep_environments(LocalFrame fr)
  947. { Code PC = NULL;
  948.  
  949.   if ( fr == (LocalFrame) NULL )
  950.     return (LocalFrame) NULL;
  951.  
  952.   for( ; ; )
  953.   { int slots;
  954.     Word sp;
  955.  
  956.     if ( false(fr, FR_MARKED) )
  957.       return (LocalFrame) NULL;
  958.     clear(fr, FR_MARKED);
  959.  
  960.     if ( false(fr, FR_CHOICEPT) )
  961.     { fr->mark.trailtop = INVALID_TRAILTOP;
  962.       fr->mark.globaltop = INVALID_GLOBALTOP;
  963.       SECURE(trailtops_marked--);
  964.     } else
  965.       clear(fr, FR_CHOICEPT);
  966.  
  967.     slots   = (PC == NULL ? fr->predicate->functor->arity : slotsFrame(fr));
  968.  
  969.     sp = argFrameP(fr, 0);
  970.     for( ; slots > 0; slots--, sp++ )
  971.     { if ( marked(sp) )
  972.       { unmark(sp);
  973.     if ( isGlobalRef(get_value(sp)) )
  974.     { local_marked--;
  975.       check_relocation(sp);
  976.       into_relocation_chain(sp, STG_LOCAL);
  977.     }
  978.       }
  979.     }
  980.  
  981.     PC = fr->programPointer;
  982.     if ( fr->parent != NULL )
  983.       fr = fr->parent;
  984.     else
  985.       return fr;            /* Prolog --> C --> Prolog calls */
  986.   }
  987. }
  988.  
  989.  
  990. static LocalFrame
  991. sweep_choicepoints(LocalFrame bfr)
  992. { for( ; ; )
  993.   { sweep_environments(bfr);
  994.     sweep_mark(&bfr->mark);
  995.     if ( !bfr->backtrackFrame )
  996.       return bfr;
  997.     else
  998.       bfr = bfr->backtrackFrame;
  999.   }
  1000. }
  1001.  
  1002.  
  1003. static void
  1004. sweep_stacks(LocalFrame fr)
  1005. { LocalFrame tfr, tbfr;
  1006.  
  1007.   while(fr)
  1008.   { tfr  = sweep_environments(fr);
  1009.     tbfr = sweep_choicepoints(fr);
  1010.  
  1011.     if ( tfr != tbfr )
  1012.       sweep_mark(&tfr->mark);
  1013.  
  1014.     fr = parentFrame(tfr);
  1015.   }
  1016. }
  1017.  
  1018.  
  1019. static void
  1020. sweep_local(LocalFrame fr)
  1021. { sweep_stacks(fr);
  1022.  
  1023.   if ( local_marked != 0 )
  1024.     sysError("local_marked = %ld", local_marked);
  1025. }
  1026.  
  1027. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1028. All preparations have been made now, and the actual  compacting  of  the
  1029. global  stack  may  start.   The  marking phase has calculated the total
  1030. number of words (cells) in the global stack that are none-garbage.
  1031.  
  1032. In the first phase, we will  walk  along  the  global  stack  from  it's
  1033. current  top towards the bottom.  During this phase, `current' refers to
  1034. the current element we are processing, while `dest' refers to the  place
  1035. this  element  will  be  after  the compacting phase is completed.  This
  1036. invariant is central and should be maintained carefully while processing
  1037. alien objects as strings and reals, which happen to have a  non-standard
  1038. size.
  1039. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1040.  
  1041. static bool
  1042. is_downward_ref(Word p)
  1043. { word val = get_value(p);
  1044.  
  1045.   switch(tag(val))
  1046.   { case TAG_INTEGER:
  1047.       if ( storage(val) == STG_INLINE )
  1048.     fail;
  1049.     case TAG_STRING:
  1050.     case TAG_FLOAT:
  1051.     case TAG_REFERENCE:
  1052.     case TAG_COMPOUND:
  1053.       return val_ptr(val) < p;
  1054.   }
  1055.  
  1056.   fail;
  1057. }
  1058.  
  1059.  
  1060. static bool
  1061. is_upward_ref(Word p)
  1062. { word val = get_value(p);
  1063.  
  1064.   switch(tag(val))
  1065.   { case TAG_INTEGER:
  1066.       if ( storage(val) == STG_INLINE )
  1067.     fail;
  1068.     case TAG_STRING:
  1069.     case TAG_FLOAT:
  1070.     case TAG_REFERENCE:
  1071.     case TAG_COMPOUND:
  1072.       return val_ptr(val) > p;
  1073.   }
  1074.  
  1075.   fail;
  1076. }
  1077.  
  1078.  
  1079. static void
  1080. compact_global(void)
  1081. { Word dest, current;
  1082. #if O_SECURE
  1083.   Word *v = mark_top;
  1084. #endif
  1085.  
  1086.   DEBUG(2, Sdprintf("Scanning global stack downwards\n"));
  1087.  
  1088.   dest = gBase + total_marked;            /* first FREE cell */
  1089.   for( current = gTop; current >= gBase; current-- )
  1090.   { long offset = (marked(current) || is_first(current)
  1091.                        ? 0 : offset_cell(current));
  1092.     current -= offset;
  1093.  
  1094.     if ( marked(current) )
  1095.     {
  1096. #if O_SECURE
  1097.       if ( current != *--v )
  1098.         sysError("Marked cell at 0x%p (*= 0x%p); gTop = 0x%p; should be 0x%p",
  1099.          current, *current, gTop, *v);
  1100. #endif
  1101.       dest -= offset + 1;
  1102.       DEBUG(3, Sdprintf("Marked cell at 0x%p (size = %ld; dest = 0x%p)\n",
  1103.             current, offset+1, dest));
  1104.       if ( is_first(current) )
  1105.     update_relocation_chain(current, dest);
  1106.       if ( is_downward_ref(current) )
  1107.       { check_relocation(current);
  1108.     into_relocation_chain(current, STG_GLOBAL);
  1109.       }
  1110.     } else
  1111.     { if ( is_first(current) )
  1112.     update_relocation_chain(current, dest);    /* gTop refs from marks */
  1113.     }
  1114.   }
  1115.  
  1116. #if O_SECURE
  1117.   if ( v != mark_base )
  1118.   { for( v--; v >= mark_base; v-- )
  1119.     { Sdprintf("Expected marked cell at 0x%p, (*= 0x%lx)\n", *v, **v);
  1120.     }
  1121.     sysError("v = 0x%p; mark_base = 0x%p", v, mark_base);
  1122.   }
  1123. #endif
  1124.  
  1125.   if ( dest != gBase )
  1126.     sysError("Mismatch in down phase: dest = 0x%p, gBase = 0x%p\n",
  1127.          dest, gBase);
  1128.   if ( relocation_cells != relocated_cells )
  1129.     sysError("After down phase: relocation_cells = %ld; relocated_cells = %ld",
  1130.          relocation_cells, relocated_cells);
  1131.  
  1132.   DEBUG(2, Sdprintf("Scanning global stack upwards\n"));
  1133.   dest = gBase;
  1134.   for(current = gBase; current < gTop; )
  1135.   { if ( marked(current) )
  1136.     { long l, n;
  1137.  
  1138.       if ( is_first(current) )
  1139.     update_relocation_chain(current, dest);
  1140.  
  1141.       if ( (l = offset_cell(current)) == 0 )    /* normal cells */
  1142.       { *dest = *current;
  1143.         if ( is_upward_ref(current) )
  1144.     { check_relocation(current);
  1145.           into_relocation_chain(dest, STG_GLOBAL);
  1146.     }
  1147.     unmark(dest);
  1148.     dest++;
  1149.     current++;
  1150.       } else                    /* indirect values */
  1151.       { Word cdest, ccurrent;
  1152.  
  1153.     l++;
  1154.     
  1155.     for( cdest=dest, ccurrent=current, n=0; n < l; n++ )
  1156.       *cdest++ = *ccurrent++;
  1157.       
  1158.     unmark(dest);
  1159.     dest += l;
  1160.     current += l;
  1161.       }
  1162.  
  1163.     } else
  1164.       current += offset_cell(current) + 1;
  1165.   }
  1166.  
  1167.   if ( dest != gBase + total_marked )
  1168.     sysError("Mismatch in up phase: dest = 0x%p, gBase+total_marked = 0x%p\n",
  1169.          dest, gBase + total_marked );
  1170.  
  1171.   DEBUG(3, { Word p = dest;        /* clear top of stack */
  1172.          while(p < gTop)
  1173.            *p++ = 0xbfbfbfbfL;
  1174.        });
  1175.  
  1176.   gTop = dest;
  1177. }
  1178.  
  1179. static void
  1180. collect_phase(LocalFrame fr)
  1181. {
  1182.   DEBUG(2, Sdprintf("Sweeping foreign references\n"));
  1183.   sweep_foreign();
  1184.   DEBUG(2, Sdprintf("Sweeping trail stack\n"));
  1185.   sweep_trail();
  1186.   DEBUG(2, Sdprintf("Sweeping local stack\n"));
  1187.   sweep_local(fr);
  1188.   DEBUG(2, Sdprintf("Compacting global stack\n"));
  1189.   compact_global();
  1190.  
  1191.   if ( relocation_chains != 0 )
  1192.     sysError("relocation chains = %ld", relocation_chains);
  1193.   if ( relocated_cells != relocation_cells ||
  1194.        relocated_cells != needs_relocation )
  1195.     sysError("relocation cells = %ld; relocated_cells = %ld, "
  1196.          "needs_relocation = %ld\n\t",
  1197.          relocation_cells, relocated_cells, needs_relocation);
  1198. }
  1199.  
  1200.  
  1201.         /********************************
  1202.         *             MAIN              *
  1203.         *********************************/
  1204.  
  1205. #if O_DYNAMIC_STACKS
  1206. void
  1207. considerGarbageCollect(Stack s)
  1208. { if ( s->gc && trueFeature(GC_FEATURE) )
  1209.   { if ( (char *)s->top - (char *)s->base > (long)(s->factor*s->gced_size + s->small) )
  1210.     { DEBUG(1, Sdprintf("%s overflow: Posted garbage collect request\n",
  1211.             s->name));
  1212.       gc_status.requested = TRUE;
  1213.     }
  1214.   }
  1215. }
  1216. #endif /* O_DYNAMIC_STACKS */
  1217.  
  1218.  
  1219. #if O_SECURE || O_DEBUG || defined(O_MAINTENANCE)
  1220. static bool
  1221. scan_global(int marked)
  1222. { Word current;
  1223.   int errors = 0;
  1224.   long cells = 0;
  1225.  
  1226.   for( current = gBase; current < gTop; current += (offset_cell(current)+1) )
  1227.   { cells++;
  1228.     if ( (!marked && marked(current)) || is_first(current) )
  1229.     { warning("Illegal cell in global stack (up) at 0x%p (*= 0x%p)",
  1230.           current, *current);
  1231.       if ( isAtom(*current) )
  1232.     warning("0x%p is atom %s", current, stringAtom(*current));
  1233.       if ( isTerm(*current) )
  1234.     warning("0x%p is term %s/%d",
  1235.         current,
  1236.         stringAtom(nameFunctor(functorTerm(*current))),
  1237.         arityTerm(*current));
  1238.       if ( ++errors > 10 )
  1239.       { Sdprintf("...\n");
  1240.         break;
  1241.       }
  1242.     }
  1243.   }
  1244.  
  1245.   for( current = gTop - 1; current >= gBase; current-- )
  1246.   { cells --;
  1247.     current -= offset_cell(current);
  1248.     if ( (!marked && marked(current)) || is_first(current) )
  1249.     { warning("Illegal cell in global stack (down) at 0x%p (*= 0x%p)",
  1250.           current, *current);
  1251.       if ( ++errors > 10 )
  1252.       { Sdprintf("...\n");
  1253.         break;
  1254.       }
  1255.     }
  1256.   }
  1257.  
  1258.   if ( !errors && cells != 0 )
  1259.     sysError("Different count of cells upwards and downwards: %ld\n", cells);
  1260.  
  1261.   return errors == 0;
  1262. }
  1263.  
  1264.  
  1265. static word key;
  1266. static int checked;
  1267.  
  1268. static void
  1269. check_mark(mark *m)
  1270. { if ( m->trailtop == INVALID_TRAILTOP )
  1271.   { assert(m->globaltop == INVALID_GLOBALTOP);
  1272.   } else
  1273.   { assert(storage(m->trailtop) == STG_TRAIL);
  1274.     assert(storage(m->globaltop) == STG_GLOBAL);
  1275.     assert(onStackArea(trail,  valPtr(m->trailtop)));
  1276.     assert(onStackArea(global, valPtr(m->globaltop)));
  1277.   }
  1278. }
  1279.  
  1280.  
  1281. static QueryFrame
  1282. check_environments(fr)
  1283. LocalFrame fr;
  1284. { Code PC = NULL;
  1285.  
  1286.   if ( fr == NULL )
  1287.     return NULL;
  1288.  
  1289.   for(;;)
  1290.   { int slots, n;
  1291.     Word sp;
  1292.  
  1293.     if ( true(fr, FR_MARKED) )
  1294.       return NULL;            /* from choicepoints only */
  1295.     set(fr, FR_MARKED);
  1296.     local_frames++;
  1297.     clearUninitialisedVarsFrame(fr, PC);
  1298.  
  1299.     check_mark(&fr->mark);
  1300.     assert(onStack(local, fr));
  1301.  
  1302.     DEBUG(3, Sdprintf("Check [%ld] %s:",
  1303.               levelFrame(fr),
  1304.               predicateName(fr->predicate)));
  1305.  
  1306.     slots   = (PC == NULL ? fr->predicate->functor->arity : slotsFrame(fr));
  1307.     sp = argFrameP(fr, 0);
  1308.     for( n=0; n < slots; n++ )
  1309.     { key += checkData(&sp[n]);
  1310.     }
  1311.     checked += slots;
  1312.     DEBUG(3, Sdprintf(" 0x%lx\n", key));
  1313.  
  1314.     PC = fr->programPointer;
  1315.     if ( fr->parent )
  1316.       fr = fr->parent;
  1317.     else
  1318.     { QueryFrame qf = (QueryFrame)addPointer(fr, -offset(queryFrame, frame));
  1319.       DEBUG(3, Sdprintf("*** Query %s\n", predicateName(qf->frame.predicate)));
  1320.       return qf;
  1321.     }
  1322.   }
  1323. }
  1324.  
  1325.  
  1326. static void
  1327. check_choicepoints(bfr)
  1328. LocalFrame bfr;
  1329. { for( ; bfr; bfr = bfr->backtrackFrame )
  1330.   { check_environments(bfr);
  1331.   }
  1332. }
  1333.  
  1334.  
  1335. static LocalFrame
  1336. lunmark_environments(fr)
  1337. LocalFrame fr;
  1338. { if ( fr == NULL )
  1339.     return NULL;
  1340.  
  1341.   for(;;)
  1342.   { if ( false(fr, FR_MARKED) )
  1343.       return NULL;
  1344.     clear(fr, FR_MARKED);
  1345.     local_frames--;
  1346.     
  1347.     if ( fr->parent )
  1348.       fr = fr->parent;
  1349.     else                /* Prolog --> C --> Prolog calls */
  1350.       return parentFrame(fr);
  1351.   }
  1352. }
  1353.  
  1354.  
  1355. static void
  1356. lunmark_choicepoints(bfr)
  1357. LocalFrame bfr;
  1358. { for( ; bfr; bfr = bfr->backtrackFrame )
  1359.     lunmark_environments(bfr);
  1360. }
  1361.  
  1362.  
  1363. word
  1364. check_foreign()
  1365. { FliFrame ff;
  1366.   word key = 0L;
  1367.  
  1368.   for(ff = fli_context; ff; ff = ff->parent )
  1369.   { Word sp = refFliP(ff, 0);
  1370.     int n = ff->size;
  1371.  
  1372.     for(n=0 ; n < ff->size; n++ )
  1373.       key += checkData(&sp[n]);
  1374.  
  1375.     check_mark(&ff->mark);
  1376.   }
  1377.  
  1378.   return key;
  1379. }
  1380.  
  1381.  
  1382. word
  1383. checkStacks(frame)
  1384. LocalFrame frame;
  1385. { LocalFrame fr, fr2;
  1386.   QueryFrame qf;
  1387.  
  1388.   if ( !frame )
  1389.     frame = environment_frame;
  1390.  
  1391.   local_frames = 0;
  1392.   key = 0L;
  1393.  
  1394.   for( fr = frame; fr; fr = qf->saved_environment )
  1395.   { qf = check_environments(fr);
  1396.     assert(qf->magic == QID_MAGIC);
  1397.  
  1398.     check_choicepoints(fr->backtrackFrame);
  1399.   }
  1400.  
  1401.   SECURE(trailtops_marked = local_frames);
  1402.  
  1403.   for( fr = frame; fr; fr = fr2 )
  1404.   { fr2 = lunmark_environments(fr);
  1405.  
  1406.     lunmark_choicepoints(fr->backtrackFrame);
  1407.   }
  1408.  
  1409.   assert(local_frames == 0);
  1410.  
  1411.   key += check_foreign();
  1412.  
  1413.   return key;
  1414. }
  1415.  
  1416. #endif /*O_SECURE || O_DEBUG*/
  1417.  
  1418.  
  1419. void
  1420. garbageCollect(LocalFrame fr)
  1421. { long tgar, ggar;
  1422.   real t = CpuTime();
  1423.   int verbose = trueFeature(TRACE_GC_FEATURE);
  1424.  
  1425.   DEBUG(0, verbose = TRUE);
  1426.  
  1427. #if O_SECURE
  1428.   key = checkStacks(fr);
  1429. #endif
  1430.  
  1431.   if ( gc_status.blocked || !trueFeature(GC_FEATURE) )
  1432.     return;
  1433.   gc_status.requested = FALSE;
  1434.  
  1435.   gc_status.active = TRUE;
  1436.   finish_foreign_frame();
  1437.   if ( verbose )
  1438.   { Putf("%% GC ... ");
  1439.     pl_flush();
  1440.   }
  1441. #ifdef O_PROFILE
  1442.   PROCEDURE_garbage_collect0->definition->profile_calls++;
  1443. #endif
  1444. #if O_SECURE
  1445.   if ( !scan_global(FALSE) )
  1446.     sysError("Stack not ok at gc entry");
  1447.  
  1448.   key = checkStacks(fr);
  1449.  
  1450.   if ( check_table == NULL )
  1451.     check_table = newHTable(256);
  1452.   else
  1453.     clearHTable(check_table);
  1454.  
  1455.   mark_base = mark_top = malloc(usedStack(global));
  1456. #endif
  1457.  
  1458.   needs_relocation  = 0;
  1459.   relocation_chains = 0;
  1460.   relocation_cells  = 0;
  1461.   relocated_cells   = 0;
  1462.   local_marked        = 0;
  1463.  
  1464.   requireStack(global, sizeof(word));
  1465.   requireStack(trail, sizeof(struct trail_entry));
  1466.   setVar(*gTop);
  1467.   tTop->address = 0;
  1468.  
  1469.   mark_phase(fr);
  1470. #ifdef O_DESTRUCTIVE_ASSIGNMENT
  1471.   mark_trail();
  1472. #endif
  1473.   tgar = trailcells_deleted * sizeof(struct trail_entry);
  1474.   ggar = (gTop - gBase - total_marked) * sizeof(word);
  1475.   gc_status.trail_gained  += tgar;
  1476.   gc_status.global_gained += ggar;
  1477.   gc_status.collections++;
  1478.  
  1479.   DEBUG(2, Sdprintf("Compacting trail ... "));
  1480.   compact_trail();
  1481.  
  1482.   collect_phase(fr);
  1483. #if O_SECURE
  1484.   assert(trailtops_marked == 0);
  1485.   if ( !scan_global(FALSE) )
  1486.     sysError("Stack not ok after gc; gTop = 0x%p", gTop);
  1487.   free(mark_base);
  1488. #endif
  1489.  
  1490.   t = CpuTime() - t;
  1491.   gc_status.time += t;
  1492.   trimStacks();
  1493.  
  1494.   SECURE(if ( checkStacks(fr) != key )
  1495.      { Sdprintf("Stack checksum failure\n");
  1496.        trap_gdb();
  1497.      } else
  1498.        Putf("(OK) "));
  1499.  
  1500.   if ( verbose )
  1501.   { Putf("(gained %ld+%ld in %.2f sec; used: %d+%d; free: %d+%d)\n",
  1502.      ggar, tgar, t,
  1503.      usedStack(global), usedStack(trail),
  1504.      roomStack(global), roomStack(trail));
  1505.   }
  1506.  
  1507.   gc_status.active = FALSE;
  1508. }
  1509.  
  1510. word
  1511. pl_garbage_collect(term_t d)
  1512. { LocalFrame fr = environment_frame;
  1513.  
  1514. #if O_DEBUG
  1515.   int ol = GD->debug_level;
  1516.   int nl;
  1517.  
  1518.   if ( !PL_get_integer(d, &nl) )
  1519.     return warning("garbage_collect/1: instantiation fault");
  1520.   GD->debug_level = nl;
  1521. #endif
  1522.   finish_foreign_frame();
  1523.   garbageCollect(fr);
  1524. #if O_DEBUG
  1525.   GD->debug_level = ol;
  1526. #endif
  1527.   succeed;
  1528. }
  1529.  
  1530. void
  1531. resetGC(void)
  1532. { gc_status.requested = FALSE;
  1533.   gc_status.blocked = 0;
  1534.   gc_status.collections = gc_status.global_gained = gc_status.trail_gained = 0;
  1535.   gc_status.time = 0.0;
  1536.  
  1537. #if O_SHIFT_STACKS
  1538.   shift_status.local_shifts = 0;
  1539.   shift_status.global_shifts = 0;
  1540.   shift_status.trail_shifts = 0;
  1541.   shift_status.blocked = 0;
  1542.   shift_status.time = 0.0;
  1543. #endif
  1544. }
  1545.  
  1546.  
  1547. #if O_SHIFT_STACKS
  1548.  
  1549.          /*******************************
  1550.          *       STACK-SHIFTER    *
  1551.          *******************************/
  1552.  
  1553. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1554. Update the Prolog runtime stacks presuming they have shifted by the
  1555. the specified offset.
  1556.  
  1557. Memory management description.
  1558. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1559.  
  1560. static inline void
  1561. update_pointer(void *p, long offset)
  1562. { char **ptr = ((char **)p);
  1563.  
  1564.   if ( *ptr )
  1565.     *ptr += offset;
  1566. }
  1567.  
  1568.  
  1569.          /*******************************
  1570.          *       LOCAL STACK        *
  1571.          *******************************/
  1572.  
  1573. static void update_choicepoints(LocalFrame, long, long, long);
  1574.  
  1575. static LocalFrame
  1576. update_environments(LocalFrame fr, Code PC, long ls, long gs, long ts)
  1577. { if ( fr == NULL )
  1578.     return NULL;
  1579.  
  1580.   for(;;)
  1581.   { int slots;
  1582.     Word sp;
  1583.     
  1584.     assert(inShiftedArea(local, ls, fr));
  1585.  
  1586.     if ( true(fr, FR_MARKED) )
  1587.       return NULL;            /* from choicepoints only */
  1588.     set(fr, FR_MARKED);
  1589.     local_frames++;
  1590.     
  1591.     DEBUG(2,
  1592.       Sdprintf("Shifting frame 0x%p [%ld] %s ... ",
  1593.          fr, levelFrame(fr), predicateName(fr->predicate)));
  1594.  
  1595.     if ( ls )                /* update frame pointers */
  1596.     { if ( fr->parent )
  1597.     fr->parent = (LocalFrame) addPointer(fr->parent, ls);
  1598.       if ( fr->backtrackFrame )
  1599.     fr->backtrackFrame = (LocalFrame) addPointer(fr->backtrackFrame, ls);
  1600.     }
  1601.  
  1602.     if ( ls )                /* update variables */
  1603.     { clearUninitialisedVarsFrame(fr, PC);
  1604.  
  1605.       slots = (PC == NULL ? fr->predicate->functor->arity : slotsFrame(fr));
  1606.       sp = argFrameP(fr, slots);
  1607.                     /* update saved BFR's from C_MARK */
  1608.       if ( ls && PC && false(fr->predicate, FOREIGN) )
  1609.       { Clause cl = fr->clause->clause;
  1610.     int saved_bfrs = cl->variables - cl->prolog_vars;
  1611.     
  1612.     for( ; saved_bfrs-- > 0; sp++ )
  1613.       update_pointer(sp, ls);
  1614.       }
  1615.     }
  1616.  
  1617.     DEBUG(2, Sdprintf("ok\n"));
  1618.  
  1619.     PC = fr->programPointer;
  1620.     if ( fr->parent )
  1621.       fr = fr->parent;
  1622.     else                /* Prolog --> C --> Prolog calls */
  1623.     { QueryFrame query = (QueryFrame)addPointer(fr, -offset(queryFrame,frame));
  1624.  
  1625.       if ( ls )
  1626.       { update_pointer(&query->bfr, ls);
  1627.     update_pointer(&query->saved_environment, ls);
  1628.     update_pointer(&query->registers.fr, ls);
  1629.     update_pointer(&query->registers.bfr, ls);
  1630.       }
  1631.       
  1632.       return query->saved_environment;    /* parent frame */
  1633.     }
  1634.   }
  1635. }
  1636.  
  1637.  
  1638. static void
  1639. update_choicepoints(LocalFrame bfr, long ls, long gs, long ts)
  1640. { for( ; bfr; bfr = bfr->backtrackFrame )
  1641.   { DEBUG(1, Sdprintf("Updating choicepoints from 0x%p [%ld] %s ... ",
  1642.               bfr, levelFrame(bfr), predicateName(bfr->predicate)));
  1643.     update_environments(bfr, NULL, ls, gs, ts);
  1644.   }
  1645. }
  1646.  
  1647.  
  1648. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1649. Clear the marks set by update_environments().
  1650. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1651.  
  1652. static LocalFrame
  1653. unmark_environments(LocalFrame fr)
  1654. { if ( fr == NULL )
  1655.     return NULL;
  1656.  
  1657.   for(;;)
  1658.   { if ( false(fr, FR_MARKED) )
  1659.       return NULL;
  1660.     clear(fr, FR_MARKED);
  1661.     local_frames--;
  1662.     
  1663.     if ( fr->parent )
  1664.       fr = fr->parent;
  1665.     else                /* Prolog --> C --> Prolog calls */
  1666.       return parentFrame(fr);
  1667.   }
  1668. }
  1669.  
  1670.  
  1671. static void
  1672. unmark_choicepoints(LocalFrame bfr)
  1673. { for( ; bfr; bfr = bfr->backtrackFrame )
  1674.     unmark_environments(bfr);
  1675. }
  1676.  
  1677.  
  1678.          /*******************************
  1679.          *      ARGUMENT STACK    *
  1680.          *******************************/
  1681.  
  1682. static void
  1683. update_argument(long ls, long gs)
  1684. { Word *p = aBase;
  1685.   Word *t = aTop;
  1686.  
  1687.   for( ; p < t; p++ )
  1688.   { if ( onGlobal(*p) )
  1689.     { *p = addPointer(*p, gs);
  1690.     } else
  1691.     { assert(onLocal(*p));
  1692.       *p = addPointer(*p, ls);
  1693.     }
  1694.   }
  1695. }
  1696.  
  1697.  
  1698.          /*******************************
  1699.          *      FOREIGN FRAMES    *
  1700.          *******************************/
  1701.  
  1702. static void
  1703. update_foreign(long ts, long ls, long gs)
  1704. { FliFrame fr = addPointer(fli_context, ls);
  1705.  
  1706.   for( ; fr; fr = fr->parent )
  1707.   { if ( fr->parent )
  1708.       fr->parent = addPointer(fr->parent, ls);
  1709.   }
  1710. }
  1711.  
  1712.  
  1713. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1714. Entry-point.   Update the  stacks to  reflect  their current  positions.
  1715. This function should be called *after*  the  stacks have been relocated.
  1716. Note that these functions are  only used  if  there is no virtual memory
  1717. way to reach at dynamic stacks.
  1718. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1719.  
  1720. #define updateStackHeader(name, offset) \
  1721.     { LD->stacks.name.base  = addPointer(LD->stacks.name.base,  offset); \
  1722.       LD->stacks.name.top   = addPointer(LD->stacks.name.top,   offset); \
  1723.       LD->stacks.name.max   = addPointer(LD->stacks.name.max,   offset); \
  1724.       LD->stacks.name.limit = addPointer(LD->stacks.name.limit, offset); \
  1725.     }
  1726.  
  1727.  
  1728. static LocalFrame
  1729. updateStacks(frame, PC, lb, gb, tb)
  1730. LocalFrame frame;
  1731. Code PC;
  1732. Void lb, gb, tb;            /* bases addresses */
  1733. { long ls, gs, ts;
  1734.   LocalFrame fr, fr2;
  1735.  
  1736.   ls = (long) lb - (long) lBase;
  1737.   gs = (long) gb - (long) gBase;
  1738.   ts = (long) tb - (long) tBase;
  1739.  
  1740.   DEBUG(2, Sdprintf("ls+gs+ts = %ld %ld %ld ... ", ls, gs, ts));
  1741.  
  1742.   if ( ls || gs || ts )
  1743.   { local_frames = 0;
  1744.  
  1745.     for(fr = addPointer(frame, ls); fr; fr = fr2, PC = NULL)
  1746.     { fr2 = update_environments(fr, PC, ls, gs, ts);
  1747.  
  1748.       update_choicepoints(fr->backtrackFrame, ls, gs, ts);
  1749.       DEBUG(1, if ( fr2 )
  1750.              Sdprintf("Update frames of C-parent at 0x%p\n", fr2));
  1751.     }
  1752.  
  1753.     DEBUG(2, Sdprintf("%d frames ...", local_frames));
  1754.  
  1755.     for(fr = addPointer(frame, ls); fr; fr = fr2)
  1756.     { fr2 = unmark_environments(fr);
  1757.  
  1758.       unmark_choicepoints(fr->backtrackFrame);
  1759.     }
  1760.     assert(local_frames == 0);
  1761.  
  1762.     if ( gs || ls )
  1763.     { update_argument(ls, gs);
  1764.     }
  1765.     update_foreign(ts, ls, gs);
  1766.  
  1767.     updateStackHeader(local,  ls);
  1768.     updateStackHeader(global, gs);
  1769.     updateStackHeader(trail,  ts);
  1770.  
  1771.     base_addresses[STG_LOCAL]  = (unsigned long)lBase;
  1772.     base_addresses[STG_GLOBAL] = (unsigned long)gBase;
  1773.     base_addresses[STG_TRAIL]  = (unsigned long)tBase;
  1774.   }
  1775.  
  1776.   if ( ls )
  1777.   { update_pointer(&environment_frame, ls);
  1778.     update_pointer(&fli_context, ls);
  1779.   }
  1780.  
  1781.   return addPointer(frame, ls);
  1782. }
  1783.  
  1784. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1785. Entry point from interpret()
  1786. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1787.  
  1788. #define GL_SEPARATION sizeof(word)
  1789.  
  1790. static long
  1791. nextStackSize(s)
  1792. Stack s;
  1793. { long size = (char *) s->max - (char *) s->base;
  1794.  
  1795.   if ( s->max == s->limit )
  1796.     outOf(s);
  1797.  
  1798.   size = ROUND((size * 3) / 2, 4096);
  1799.   if ( addPointer(s->max, size) > s->limit )
  1800.     size = diffPointers(s->limit, s->max);
  1801.  
  1802.   return size;
  1803. }
  1804.  
  1805.  
  1806. int
  1807. growStacks(LocalFrame fr, Code PC, int l, int g, int t)
  1808. { if ( fr == NULL || PC != NULL )    /* for now, only at the call-port */
  1809.     fail;
  1810.  
  1811.   if ( (l || g || t) && !shift_status.blocked )
  1812.   { TrailEntry tb = tBase;
  1813.     Word gb = gBase;
  1814.     LocalFrame lb = lBase;
  1815.     long lsize = sizeStack(local);
  1816.     long gsize = sizeStack(global);
  1817.     long tsize = sizeStack(trail);
  1818.     real time = CpuTime();
  1819.     int verbose = trueFeature(TRACE_GC_FEATURE);
  1820.     
  1821.     DEBUG(0, verbose = TRUE);
  1822.  
  1823.     if ( verbose )
  1824.     { int i = 0;
  1825.  
  1826.       Putf("Expanding ");
  1827.       if ( l ) Putf("%s%s", i++ ? "and " : "", "local ");
  1828.       if ( g ) Putf("%s%s", i++ ? "and " : "", "global ");
  1829.       if ( t ) Putf("%s%s", i++ ? "and " : "", "trail ");
  1830.       Putf("stacks ");
  1831.     }
  1832.  
  1833.     finish_foreign_frame();
  1834.  
  1835.     if ( !fr )
  1836.       fr = environment_frame;
  1837.  
  1838.     SECURE(key = checkStacks(fr));
  1839.  
  1840.     if ( t )
  1841.     { tsize = nextStackSize((Stack) &LD->stacks.trail);
  1842.       tb = xrealloc(tb, tsize);
  1843.       shift_status.trail_shifts++;
  1844.     }
  1845.  
  1846.     if ( g || l )
  1847.     { long loffset = gsize + GL_SEPARATION;
  1848.       assert(lb == addPointer(gb, loffset));    
  1849.  
  1850.       if ( g )
  1851.       { gsize = nextStackSize((Stack) &LD->stacks.global);
  1852.     shift_status.global_shifts++;
  1853.       }
  1854.       if ( l )
  1855.       { lsize = nextStackSize((Stack) &LD->stacks.local);
  1856.     shift_status.local_shifts++;
  1857.       }
  1858.  
  1859.       gb = xrealloc(gb, lsize + gsize + GL_SEPARATION);
  1860.       lb = addPointer(gb, gsize + GL_SEPARATION);
  1861.       if ( g )                /* global enlarged; move local */
  1862.     memmove(lb,   addPointer(gb, loffset), lsize);
  1863.          /* dest, src,                     size */
  1864.     }
  1865.       
  1866.     if ( verbose )
  1867.     { Putf("to (l+g+t) = %d+%d+%d Kbytes ... ",
  1868.        lsize / 1024,
  1869.        gsize / 1024,
  1870.        tsize / 1024);
  1871.       pl_flush();
  1872.     }
  1873.  
  1874. #define PrintStackParms(stack, name, newbase, newsize) \
  1875.     { Sdprintf("%6s: 0x%08lx ... 0x%08lx --> 0x%08lx ... 0x%08lx\n", \
  1876.          name, \
  1877.          (unsigned long) LD->stacks.stack.base, \
  1878.          (unsigned long) LD->stacks.stack.max, \
  1879.          (unsigned long) newbase, \
  1880.          (unsigned long) addPointer(newbase, newsize)); \
  1881.     }
  1882.  
  1883.  
  1884.     DEBUG(0, { Sputchar('\n');
  1885.            PrintStackParms(global, "global", gb, gsize);
  1886.            PrintStackParms(local, "local", lb, lsize);
  1887.            PrintStackParms(trail, "trail", tb, tsize);
  1888.          });
  1889.             
  1890.     DEBUG(1, Sdprintf("Updating stacks ..."));
  1891.     fr = updateStacks(fr, PC, lb, gb, tb);
  1892.  
  1893.     LD->stacks.local.max  = addPointer(LD->stacks.local.base,  lsize);
  1894.     LD->stacks.global.max = addPointer(LD->stacks.global.base, gsize);
  1895.     LD->stacks.trail.max  = addPointer(LD->stacks.trail.base,  tsize);
  1896.  
  1897.     SetHTop(LD->stacks.local.max);
  1898.     SetHTop(LD->stacks.trail.max);
  1899.  
  1900.     time = CpuTime() - time;
  1901.     shift_status.time += time;
  1902.     SECURE(if ( checkStacks(fr) != key )
  1903.        { Sdprintf("Stack checksum failure\n");
  1904.          trap_gdb();
  1905.        });
  1906.     if ( verbose )
  1907.     { Putf("%.2f sec.\n", time);
  1908.     }
  1909.  
  1910.     succeed;
  1911.   }
  1912.  
  1913.   fail;
  1914. }
  1915.  
  1916. #endif /*O_SHIFT_STACKS*/
  1917.